perm filename NOTWRT.F4[MSS,LCS]1 blob sn#086976 filedate 1974-03-19 generic text, type T, neo UTF8
00100		SUBROUTINE NOTWRT
00200		IMPLICIT INTEGER(A-Q,S-Z)
00300		COMMON/DL/IXRX,M,AA
00400		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
00500		DIMENSION SU(250),RACNT(52),RDOT(7),XAC(6)
00600		REAL DIS,PWDS,CENTR,POS,STFF
00700		COMMON /STF/RSTFAC(8),RSTJC
00800		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00900		COMMON/PLTR/PLT,RHT,DIS/XRN/RN(4000)/POSI/STFF(8),JJB,POS
01000		COMMON/NW/FILL(7),RNOTE(24)
01100		COMMON /NU/NUMQ(44),RNUMS(327),RACCI(32),NACCI(3)
01200	C   FOR NOTE DRAWING
01300		EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJD,RJQ(2))
01400		1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
01500		1,(JK,JQ(9)),(JF,JQ(4)),(RJE,RJQ(3)),(SU(1),RN(3001))
01600		1,(RJH,RJQ(6)),(RJG,RJQ(5)),(RX,JRX)
01700		DATA RACNT/4.0,1000.005,17.0,0.105, 8.0,1003.0, 7.014, 11.0
01800		1,13. ,1000. ,0.010,14.01,14. ,17. ,1001.018,7. ,13.018,27.,
01900		1 1004., 4.002, 6.004, 8.004,10.002,10., 8.102,6.102,4.
02000		1,32.0,1000.0,14.0,1007.007,7.107, 43.0,1012.01,11.006,9.003
02100		1, 7.001, 5.0, 9.002, 13.006, 15.01, 10.004, 13.009, 52.0,
02200		1 1002.008,3.003, 5.001, 8.0, 10.0, 13.001, 15.003, 16.008/
02300		DATA RDOT/1000.0, 0.103, 1.0, 1.103, 2.0, 2.103,0/
02400		1 , R5/5.0/, R66/66.0/, R72/72.0/,R18/18.0/,RSTM/14.54/
02500		1 ,XAC/9,14,18,28,33,44/
02600	C   ALL DATA NUMS OVER 90 GIVE INVISIBLE VECTORS
02900		RST3=3.*RSTJC
03000		RST4=4.*RSTJC
03200		RST7=7.*RSTJC
03300		RSTX=RSTJC
03400	C  FOR MINIS AT 245
03500	
03600	1	CENTR=POS-R18*RSTJC+AMOD(RJD,100.0)*RST7
03700	C   'CENTR' IS VERTICAL PLACEMENT
03800		IF(JA.EQ.9)GO TO 90
03900		RMINI=RSTJC
04000	C  OR SHOULD THIS ONLY BE IN NOTES, ETC?  15/9/72
04100	
04200		IF(JA.EQ.101)GO TO 110
04300		RJB=JB
04400		RINV=1
04500	551	GO TO (11,20,30,241,50,242,70,80,90,11,30,80),JA
04700		IF(JA.EQ.30)GO TO 571
04800	C   FOR BEAMS.
04900	90	CALL ITMSUB
05000		RETURN
05100	
05200	20	IF(JE.GT.1)RJD=RJD-2
05300		RA=RJD
05400		RJG=RJF*10.
05500	C  FOR DOTS
05600	202	CALL REST
05700		IF(JE.GT.1)GO TO 200
05800		IF(RJG.EQ.0)RETURN
05900	201	L=14
06000		IF(JE)L=19
06100		JB=JB+L*RSTJC
06200		RJD=8.+RA
06300		JA=6
06400		JE=7
06500	C   IF P6=1 THE REST IS DOTTED
06600		GO TO 1
06700	200	JE=JE-1
06800	C  FOR MULTIPLE TAILS ON 16TH REST, ETC.
06900		RJD=RJD+2.
07000		RJB=RJB+RST4
07100		GO TO 202
07200	80	CALL SLUR
07300		RETURN
07400	
07500	C  FOR TREMOLO SLASHES
07600	571	RJB=RJB+1
07700		RX=14.*RSTJC
07800		RJX=CENTR+RST7
07900		RJY=RJX-RX
08000		IF(JE.EQ.10)GO TO 42
08100		CALL EXCH(RJX,RJY)
08200		RJB=RJB-RX+1
08300	42	RX=RJB+26*RSTJC
08400		DO 40 K=1,JF
08500		DO 41 L=0,2
08600		RA=L*RSTJC
08900	41	CALL LINX(RJB,RJX+RA,RX,RJY+RA)
09000		RJX=RJX+RST7
09100	40	RJY=RJY+RST7
09200		RETURN
09300	
09400	C FOR USER-DRAWN LIBRARY OF SYMBOLS
09500	30	CALL CLEFS
09600		RETURN
09700	291	RJB=RJB+8.*RSTJC
09800		IF(RINV)CENTR=CENTR-RST3
09900	C  REMOVE '8' LATER
10000		CENTR=CENTR+2*RSTJC
10100	
10200	29	RJX=RJB
10300		RJY=CENTR+RSTJC
10400	108	CALL RDRAW(1,7.0,RDOT,RSTJC,RJX,RJY,RSTJC)
10500		IF(JA.EQ.1.OR.RJG.GE.20.)GO TO 290
10600		RB=POS+52.*RSTJC
10700		IF(RJY.NE.RB)GO TO 6241
10800	C   WHERE IS RB USED LATER?
10900		RJY=RJY-12*RSTJC
11000		GO TO 108
11100	C  ABOVE FOR DOTS
11200	290	RJG=RJG-10.
11300		IF(RJG.LT.10.)GO TO 1342
11400		RJX=RJX+RSTJC*13.
11500		GO TO 108
11600	
11700	
11800	C  FOR LEDGER LINES
11900	70	JK=JD
12000	C   NOTE #
12100	170	RJW=RJB-9.*RMINI
12200		RJZ=RJB+22.*RMINI
12400		IF(JK)GO TO 71
12500		JX=JK
12600		JRX=13
12700	C********* 18/9/72
12800		GO TO 711
12900	71	JX=-JK
13000		JRX=JK*2+3
13100	711	RX=POS-18*RSTJC+RST7*JRX
13200	C********* 18/9/72
13300		IF(JF)RJZ=RJZ+2*RMINI
13400	C126	IF(PLT.EQ.-3)GO TO 1126
13500	C  FOR 2-PASS PLOTTING
13600	C   ******* ABOVE IS NOT USED, 15/9/72
14000	126	CALL LINX(RJW,RX,RJZ,RX)
14200	1126	IF(JX.EQ.1)GO TO 1122
14300		RX=RX+RSTJC*14.
14400		JX=JX-1
14500		GO TO 126
14600	1122	IF(JA.EQ.7)RETURN
14700		JI=-1
14800		GO TO 1121
14900	
15000	11	STEM=JE/10
15100	
15200	C  NOTES****
15300	C	RACTX=ABS(AMOD(RJF,1.0))*10.
15400		RJF=ABS(AMOD(RJF,1.0))*10.
15500	C   RJF WILL HAVE ACCENT CODE # (.7=DOT, ETC.)
15600	1011	RG=19.0
15700		KL=1
15900		IF(PLT.NE.-1)RG=14.
16000	C  FOR 2-PASS PLOTTING
16100		RJAC=RJB
16200	C   TO SAVE POS. OF NOTE FOR ACCENT
16300		IF(IABS(JD).LT.100)GO TO 1221
16400		IF(IABS(JD).LT.200)GO TO 1012
16500		RG=24.0
16600		KL=20
16700	C  FOR DIAMOND NOTES.
16800		GO TO 1013
16900	1012	RMINI=.6*RSTJC
17000	C  FOR RMINI NOTES
17100	1013	JD=MOD(JD,100)
17200		RJD=RJD-100.
17300		IF(RJD.GT.160.)GO TO 1013
17400	C  FOR MINI TAILS AND ACCIS. ETC.
17500	1221	JY=IABS(JF)
17600		IF(JY.LT.10.OR.JY.GE.30)GO TO 2221
17700	C P6 FOR HOMING TO RIGHT(10,30) OR LEFT(20) OF STEM(10,30=UP, 20=DOWN)
17800	C P6<0 = WHITE NOTE
17900		RQ=RSTM
18000		IF(JF)RQ=RQ+1.66
18100	C GETS WIDTH OF NOTE DISPLACEMENT
18200		IF(JY.EQ.20)RQ=-RQ
18300		RJB=RJB+RQ*RMINI
18400	2221	IF((JD.GT.1.AND.JD.LT.13).OR.JI.NE.0)GO TO 1121
18500	C   ARE THERE LEDGER LINES?
18600		JK=(JD+1)/2-6
18700		IF(JK)JK=-((3-JD)/2)
18800		GO TO 170
18900	C  IF JF≠0 NOTE IS FILLED IN
19000	1121	IF(JF.GE.0.AND.KL.EQ.1)GO TO 125
19100		CALL RDRAW(KL,RG,RNOTE,RMINI,RJB,CENTR,RMINI)
19200		GO TO 123
19300	125	IF(PLT)GO TO 1251
19400		CALL LINES(RJB,CENTR,3)
19600		RG=4.0
19700		GO TO 1253
19800	1251	CALL NOIR(RMINI)
19900		GO TO 123
20000	
20100	1253	RG=RMINI*RG
20200		RA=RJB+RG
20400		DO 1252 K=1,7,3
20500		RB=FILL(K)*RMINI
20600		CALL LINES(RA,CENTR+RB,2)
20700		CALL LINES(RA,CENTR-RB,2)
20800	1252	RA=RA+RG
20900	C   ABOVE IS NEW NOTES ROUTINE
21000	
21100	123	RJE=RJE-JE
21200	C  RJE=STEPS TO LEFT FOR ACCID. (.1=1 STEP)
21300		IF(STEM.EQ.0)GO TO 1242
21400	128	JG=MOD(JG,10)
21500		RG=(JG-1)*14
21600		IF(RG)RG=0
21700		IF(RJH.GE.999)RJH=0
21800	C   NO EXTEN. OF STEM?
21900		RH=RJH*RST7
22000	C  STEM EXTENSIONS ARE BY NOTE #S
22100		IF(STEM.NE.2)GO TO 1280
22200		RJX=RJB
22300	C  FOR STEM DOWN (=2)
22400		RG=-RG-48.
22500		RH=-RH
22600		L=20
22700		RJY=3.
22800		RJD=RJD-3.7-RJH
22900	C RJD IS USED IN SUBR. TAIL   - RJH IS STEM EXTENSION.
23000		RJW=-2
23100		RA=1.
23200		GO TO 129
23300	C  NEXT IS FOR STEM UP.
23400	1280	RJX=RSTM
23500		RJW=2
23600	C  FOR VERT. SPACING OF MULTIPLE TAILS
23700		RJD=RJD-2+RJH
23800	C  2 ABOVE AND 3.7 BEFORE ARE BECAUSE ORIG. POS. OF TAIL DRWING IS OFF.
23900		IF(JF.NE.0.AND.JF.NE.30)RJX=16.2
24000	C  FOR HALF NOTES
24100		RJX=RJX*RMINI+RJB
24200		RG=RG+48.
24300		L=10
24400		RJY=-3.
24500		RA=-1.
24600	129	RJZ=CENTR+RH+RG*RMINI
24700		IF(RMINI.NE.RSTJC)RJW=RJW*.6
25200		CALL LINX(RJX,CENTR,RJX,RJZ)
25400	227	JE=JE-L
25500	C   JE HAS ACCID. # NOW
25600		IF(JG.EQ.0)GO TO 1242
25700	C   JUMP IF NO TAILS
25800	127	CALL TAIL(RJX,RA,RMINI)
25900	1028	JG=JG-1
26000		IF(JG.EQ.0)GO TO 327
26100		RJD=RJD+RJW
26200	C  MOVES CENTR UP OR DOWN FOR NEXT TAIL
26300		GO TO 127
26400	327	IF(JJ.EQ.0)GO TO 1242
26500		RJY=RJZ-19*RSTJC
26600		RJZ=RJZ-RST4
26800		IF(RA.LT.0)GO TO 1327
26900	C  NEXT IS FOR STEM DOWN SLASH
27000		RJY=RJZ+23*RSTJC
27100		RJZ=RJZ+RST7
27200	1327	RJX=RJX-RST7
27500		CALL LINX(RJX,RJY,RJX+17.*RSTJC,RJZ)
27600	C  FOR SLASH ON GRACE NOTE TAIL
27700	1242	IF(RJG.LT.10.)GO TO 1342
27800	C  FOR DOTTED NOTE-- P7>9 
27900		RJX=RJAC+(24.+AMOD(RJG,1.0)*59.6)*RMINI
28000		RJY=CENTR+RSTJC
28300		IF(JY.EQ.10.OR.JY.EQ.30)RJX=RJX+RSTM
28350	C  MOVES DOT TO LEFT
28400		IF(MOD(JD,2).EQ.0)GO TO 108
28500		RX=RST7
28600		IF(JY.GE.20)RX=-RX
28700	3342	RJY=RJY+RX
28800		GO TO 108
28900	C  JY=30= STEM UP, INTERVAL OF SECOND.
29000	1342	RJB=RJB-RJE*59.6*RMINI
29100	C  TO SPACE OUT ACCIDS.
29200		IF(RMINI.NE.RSTJC)RSTJC=.7*RSTJC
29300	C   ↑↑↑↑		  ↑↑↑↑↑ WAS RMINI
29400	C********* 18/9/72
29500	242	IF(JE.GE.0)GO TO 2421
29600		RINV=-RINV
29700		JE=-JE
29800	C  NOW THAT 0 IS NOT USED FOR DOTS THE ABOVE 3 LINES COULD BE CHNGD
29900	C********** LAST # WAS 281?
30000	C b,#,NAT, ACC ∧, ACC >, FERMATA, DOT, REP MEAS., DASH
30100	2421	RH=14
30200		IF(JA.NE.6)GO TO 211
30300		STEM=0
30400	C   FOR MISC. ITEMS
30500	210	IF(IABS(JD).LT.100)GO TO 3241
30600		JD=MOD(JD,100)
30700		RSTJC=.7*RSTJC
30800	3241	JEX=-1
30900	C FOR 2 MARKS AT ONCE.
31000	1241	IF(JE.GE.11)GO TO 28
31100		GO TO (211,211,211,28,28,222,249,60,27,27),JE
31200		RETURN
31300	C  ERROR TRAP (I.E. JE=0)
31400	
31500	241	CALL LINES(RJB,CENTR,3)
31600		GO TO 210
31700	
31800	2422	IF(RJF.EQ.0)RETURN
32000		RJB=RJAC
32200		JE=(RJF+.001)*100.
32300	1249	IF(MOD(JE,10).GT.3)GO TO 249
32400		JE=JE/10
32500		IF(JE.GT.30)GO TO 1249
32600	C EXTRACTS ACCENT NUMBERS FROM DECIMALS IN P6.
33500	C  ↑↑↑↑		  ↑↑↑↑↑ WAS RMINI
33600	C   WHAT ABOUT MINI ACCENTS?
33700	249	IF(JE.GT.30)GO TO 28
33800		IF(JE.GT.10)GO TO 246
33900		IF(JA.NE.1)GO TO 250
34000		RH=8
34100		RB=14.
34200		IF((JE.NE.7.AND.JE.NE.9).OR.MOD(JD,2).EQ.0)GO TO 244
34300		IF((STEM.LE.1.AND.JD.LT.5).OR.((STEM.EQ.2.OR.STEM.EQ.0)
34400		1 .AND.JD.GT.9))GO TO 244
34500		RB=21
34600	C   PUTS ACCENT DOWN OR UP 1 SPACE. AVOIDS PUTTING DOT OR DASH ON LINE
34700	244	IF(STEM.EQ.1.OR.(STEM.EQ.0.AND.JD.LT.7))RB=-RB
34800		IF(JE.NE.6)GO TO 245
34900		IF(JD.LT.9.AND.STEM.EQ.2)GO TO 247
35000		IF(JD.GT.4.AND.STEM.EQ.1)GO TO 252
35100	245	CENTR=CENTR+RB*RSTX
35200	250	IF(JE.GT.10.OR.JE.LT.6)GO TO 247
35300		JA=6
35400		IF(JE.NE.7)GO TO 253
35500	C   7=DOT
35600		RXX=RJB
35700		RJB=RJB+6.7*RMINI
35800	C  CENTERS THE DOT
35900		GO TO 29
36000	253	IF(JE.EQ.9)GO TO 271
36100	C   9=DASH
36200	251	IF(RB.LT.0)RINV=-RINV
36300	C   FIX THIS!!!!  FOR BOWINGS, ETC.
36400	222	CALL FERMTA(RINV)
36500		GO TO 5241
36600	252	RX=POS
36700	248	CENTR=RX
36800		GO TO 251
36900	246	IF(STEM.EQ.1)RB=70.
37000		IF(STEM.EQ.2)RB=21.
37100	C  CHANGE R66 AND R72 TO NUMS WHEN RIGHT ONES ARE FOUND.
37200		GO TO 245
37300	247	RX=POS+R72*RSTJC
37400		IF(JE.EQ.6.OR.JE.EQ.26)GO TO 248
37500	C  26 IS NEW NUMB FOR FERMATA. TAKE OUT 6 EVENTUALLY.
37600		IF(JA.EQ.1.AND.JE.GT.10.AND.CENTR.LT.RX)CENTR=RX
37800	28	IF(JE.LT.30)GO TO 281
37900		JEX=MOD(JE,10)
38000	C  JEX SAVES NEXT MARK.
38100		IF(JEX.LT.4)JEX=0
38200		JE=JE/10
38300		IF(JE.GT.30)RETURN
38400	C  WON'T READ 415 ETC. (CORRECT=154)
38500	C DOES BOTTOM MARK FIRST, THEN TOP.
38600		CALL EXCH(JEX,JE)
38700	C  PUTS UPBOW, DNBOW, ETC. ABOVE STACC., ETC.
38800		IF(JA.EQ.1)GO TO 249
38900		GO TO 1241
39000	281	X=1
39100		IF(JE.NE.4)GO TO 228
39200		X=5
39300		RJB=RJB+.5*RSTJC
39400		GO TO 328
40100	228	IF(JE.GT.10)X=XAC(JE-10)
40200	C   X IS POINTER IN RACNT ARRAY
40300	328	RA=RMINI
40400	C   OR RSTJC?
40500		IF(RINV.LT.0.OR.(STEM.EQ.1.AND.JE.EQ.4))RA=-RA
40600		CALL RDRAW(X+1,RACNT(X),RACNT,RA,RJB,CENTR,RMINI)
40700	C              PTR, WDCNT, ARRAY,Y MULT,HOR ADD,VERT ADD, X,Y,MULT
40800	C  IN ARRAY, 33.012 WOULD BE X=33, Y=12.  101.123 IS X=-1, Y=-23.
40900		GO TO 5241
41000	4241	JJJ=JE
41100		JE=JEX
41200		JEX=-1
41300		IF(JA.NE.1)GO TO 7241
41400		IF(JE.GT.10)GO TO 246
41500		IF(JE.EQ.7.AND.JJJ.NE.9)GO TO 249
41600	7241	RXX=RH*RMINI
41700		IF(STEM.EQ.1)RXX=-RXX
41800		CENTR=CENTR+RXX
41900		IF(JE.EQ.26)JE=6
42000	C  TEMPORARY?? FIX
42100		GO TO 1241
42200	C >=5,  ∧=4
42300	27	RJB=JB
42500	C  DASHES
42700	271	CALL LINX(RJB,CENTR,RJB+RSTJC*14.,CENTR)
42800	5241	IF(JEX.GT.0)GO TO 4241
42900	C JEX IS FOR DOUBLE MARKS.  (WHAT ABOUT DOT POSITION.)
43000		RETURN
43100	6241	RJB=RXX
43200	C  RESET RJB AFTER A DOT.
43300		GO TO 5241
43400	211	IF(JE.EQ.0)GO TO 2422
43500		IF(JE.GT.3)GO TO 222
43700	C  FOR 2-PASS PLOTTING (-2=THIN LINES, -3=HEAVY LINES)
43800		X=NACCI(JE)
44000		CALL RDRAW(X+1,RACCI(X),RACCI,RMINI,RJB,CENTR,RMINI)
44200		GO TO 2422
44300	
44400	500	RJB=RJB-RST3
44500		JJB=JJB-RSTJC*13.
44600	C   ADJUSTS POS. OF #S
44700		JE=JE-1
44800		GO TO 222
44900	C NUMBERS.  5, POS, STF, NOTE #, NUM, SIZE(DECI'S)
45000	50	RDIS=RJE
45100		JJJ=JF
45200		IF(RDIS.EQ.0)RDIS=1.
45300		PUNCT=0
45400		IF(JJJ.LT.44)GO TO 51
45500		PUNCT=JJJ
45600		IF(JJJ.EQ.44)JJJ=38
45700		IF(JJJ.GE.45)JJJ=36
45800		IF(JF.NE.46)GO TO 51
45900		RXX=4
46000		RJB=RJB-RXX*RSTJC
46100		RX=16
46200		CENTR=CENTR+RX*RSTJC
46300	51	RX=RDIS*RSTJC
46400	451	X=NUMQ(JJJ+1)
46500	C  X=END # OF ITEM
46600	C  X+1=1ST PART OF ITEM
46700	      CALL RDRAW(X+1,RNUMS(X),RNUMS,RX,RJB,CENTR+RST3,RX)
46800		IF(PUNCT.EQ.0)GO TO 151
46900		IF(PUNCT.NE.46)GO TO 351
47000		RJB=RJB+2*RXX*RSTJC
47100	C  FOR "
47200	651	PUNCT=0
47300		GO TO 451
47400	351	RXX=11
47500	C FOR : AND ;
47600		CENTR=CENTR+RXX*RSTJC
47700		JJJ=38
47800		GO TO 651
47900	151	IF(JA.EQ.101)GO TO 1005
48000		RETURN
48100	
48200	110	JC=RJB
48300		IF(JC.NE.99)GO TO 1008
48400		CALL HYDPOG(2)
48500		RETURN
48600	1008	JF=0
48700		JE=0
48800		RSTJC=1.
48900	C  SETS UP SCALE LINES.
49000		RJC=STFF(JC+4)+60 
49100		RJ=RJC+60
49200		CENTR=RJC+74
49300		CALL DPYSET(2,SU,250)
49400		CALL DPYBRT(1)
49500	1001	POS=RJC+64
49600		DO 1002 MX=10,200,10
49700		RA=RHORZ(FLOAT(MX))
49800		RJB=RA-58
49900		IF(MX.GT.10)GO TO 50
50000	1005	IF(RJE.NE.0)GO TO 1007
50100	C  JUMP FOR STAFF NUMBERS
50400		CALL LINX(RA,RJC,RA,RJ)
50500		JF=JF+1
50600	1002	IF(JF.EQ.10)JF=0
50700		CALL LINES(-596.0,RJ,2)
50800		CALL LINES(-596.0,RJC,2)
50900		RJE=1.5
51000	C  NEXT SETS UP STAFF NUMBERS
51100		RJB=-620.
51200		DO 1007 K=-3,4
51300		CENTR=STFF(K+4)+21.
51400		JF=IABS(K)
51500		GO TO 50
51600	1007	CONTINUE
51700		CALL DPYOUT(2)
51800		CALL SETPOG(1)
51900		RETURN
52000	
52100	C  FOR 1 OR 2 BAR REP SIGNS.
52200	60	CALL BREP(RJB,RSTJC)
52300		END